#!/usr/bin/perl -w
# new_parser.pl
# Copyright (C) 2006  Stephane Alnet
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 3
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
# 

# This program generates a parser for the CCN configuration syntax.

use strict;
use warnings;

our $syntax_html = 0;
our $syntax_text = 0;
shift(@ARGV), $syntax_html = 1  if $ARGV[0] eq '-p';
shift(@ARGV), $syntax_text = 1  if $ARGV[0] eq '-t';


if($syntax_html)
{
    print STDERR "<dl>\n";
}

# syntax parser

our @stack;

sub do_line($$$)
{
    my ($level,$what,$do) = @_;

    $level = length($level)/4;
    $what =~ s/^\s+//;
    $what =~ s/\s+$//;
    $what =~ s/\s+/ /;

    my @what = split(' ',$what);
    my @patterns = ();
    my @cleans   = ();

    my $pattern = $what;
    $pattern =~ s/\$(\w+)(\+?)/ $a = $2 eq '+' ? 's' : ''; push @cleans, "qr_$1_clean$a"; "(\$qr_$1$a)"/ge;

    my %r = ();
    my $r = join('',values %r);

    my $p = '';
    $p = join('', map { (' 'x12)."my \$_$_ = ".$cleans[$_-1]."(\$$_);\n" } (1..$#cleans+1) );
    my $q = '';
    $q = join('', map { (' 'x12)."my \@_$_ = ".$cleans[$_-1]."(\$$_);\n" } (1..$#cleans+1) );

    $do = "{\n$p$q$r$do}" if $do !~ /^\s*$/;

    $#stack = $level;
    my $name = $what;
    $name =~ s/\$/_/g;
    $name =~ s/\+/-/g;
    $name =~ s/[^a-zA-Z0-9 _-]//g;
    $stack[$level] = $name;
    my $context1 = join(' ',@stack[0..$level-1]);
    $context1 =~ s/\s*\$\w+\+?//g;
    my $context2 = join(' ',@stack);
    $context2 =~ s/\s*\$\w+\+?//g;
    my $level2 = $level + 1;
    # warn "**** Suspicious syntax spec" if $context2 =~ /'|\\/;

    if($syntax_html)
    {
        my $w = $what;
        $w =~ s{\$(\w+)(\+?)}{"<i>$1".($2 eq '+' ? " ($1 ...)" : "")."</i>"}ge;
        print STDERR "<dt>${w}</dt>\n";
        my $c;
        if($level > 0)
        {  $c = $stack[$level-1]; $c = "<i>$c</i>" }
        else
        { $c = '<i>(root)</i>' }
        $c =~ s{\s_(\w+)(-?)}{" </i>$1".($2 eq ''? '':'&nbsp;('.$1.'&nbsp;...)')."<i>"}ge;
        print STDERR "<dd><p>Context: $c<p>";
    }
    if($syntax_text)
    {
        my $w = $what;
        print STDERR "  "x$level.$w."\n";
    }

    return ($what[0], <<EOSRC);
        if(     \$level >= ${level2}-1
            and \$context =~ /^${context1}/
            and /^${pattern}/ )
        {
            warn "state '${context1}' match '\$_'" if \$check;
            ${do}
            s/^${pattern}\\s*//;
            \$level = ${level2};
            \$context = '${context2}';
            return 1;
        }
EOSRC

}

my %syntax = ();
while(<>)
{
    chomp; s/\s+$//;

    if( $syntax_html and /^\s*#-/ )
    {
        s/^\s*#-//;
        print STDERR "$_\n";
        next;
    }

    next if /^\s*#/;
    next if /^\s*$/;

    my ($k, $v);

    if( /^(\s*)(\S[^\{]*?)\s*\{\s*$/ )
    {
        my ($l1,$l2) = ($1,$2);
        my $do = '';
        while(<>)
        {
            chomp;
            last if /^\s*\}\s*$/;
            $do .= "$_\n";
        }
        ($k,$v) = do_line($l1,$l2,$do);
        $syntax{$k} .= $v;
        next;
    }

    ($k,$v) = do_line($1,$2,$3), $syntax{$k} .= $v, next
        if /^(\s*)(\S[^\{]*?)\s*\{\s*(.*)\s*\}$/;
    ($k,$v) = do_line($1,$2,''), $syntax{$k} .= $v, next
        if /^(\s*)(\S[^\{]*?)$/;

    die "Invalid syntax description $_";
}

my $output = join( ",\n", map { "    '$_' => sub {\n".$syntax{$_}."\n    return ''; }" } sort keys %syntax);

if($syntax_html)
{
    print STDERR "</dl>\n";
}

my $qs = '';
for my $name (qw(server cluster number name route trunk))
{
    my $q = <<'PERL';
our $qr_${name}s = qr((?:$qr_${name}\s+)*$qr_${name});
sub qr_${name}_cleans($)
{
    my @a = split(' ',shift);
    @a = map { qr_${name}_clean($_) } @a;
    return wantarray ? @a : join(' ',@a);
}

PERL

    $q =~ s/\$\{name\}/$name/g;
    $qs .= $q;
}


print <<'PERL00'.<<'PERL0'.$qs.<<'PERL1'.$output.<<'PERL2';
#!/usr/bin/perl -w
# local-configure-parser.pl
# Copyright (C) 2006  Stephane Alnet
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 3
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
# 
PERL00

# This is the single-system configuration script.
# It configures a host based on the system-wide configuration file.

use strict;
use warnings;

use FileHandle; # for macros and includes

our $check = 0; # Internal-only: checks the parser
shift(@ARGV), $check = 1 if $ARGV[0] eq '-c';

our $dbh;

if( not $check )
{
    use DBI;
    my $db = shift;
    die "ERROR: Database $db already exist" if -e $db;
    $dbh = DBI->connect("dbi:SQLite:dbname=$db","","",{ RaiseError => 1, AutoCommit => 1 })
        or die "DBI_connect($db): ".$DBI::errstr;
    $dbh->do(q(CREATE TABLE single_valued ( key TEXT, value TEXT, PRIMARY KEY (key) );))
        or die "CREATE TABLE: ".$dbh->errstr;
    $dbh->do(q(CREATE TABLE multi_valued ( key TEXT, rank INTEGER, value TEXT, PRIMARY KEY (key,rank) );))
        or die "CREATE TABLE: ".$dbh->errstr;
}


# S 'name', value   ->  creates _{NAME}_ which can be parsed by t'name'
our %local_env = ();

sub S($$) # Set local
{
    $local_env{lc($_[0])} = $_[1];
}

sub t($)
{
    my $content = shift;
    $content =~ s{_\{(\w+)\}_}{exists $local_env{lc($1)} ? $local_env{lc($1)} : ((print STDERR "** UNDEFINED: $1 in '$content'\n"), uc($1))}gse;
    $content =~ s{_\{(\w+):(.*?)\}_}{exists $local_env{lc($1)} ? $local_env{lc($1)} : $2}gse;
    $content =~ s{_\{LEN(\d*):(\w+)\}_}{exists $local_env{lc($2)} ? length($local_env{lc($2)})+($1||0) : ((print STDERR "** UNDEFINED: $2 in '$content'\n"), uc($2))}gse;
    return $content;
}

# New versions for the larger database
sub Pn($$)  # Put new: add a new record
{
    # $table, \%set
    ccnsql::insert($dbh,@_);
}

sub Pp($$$) # Put put: modify a field in an existing record (follows a Pn)
{
    # $table, \%where, \%set
    ccnsql::update($dbh,@_);
}

sub Ap($$$)
{
    my ($table,$where,$set) = @_;
    # The rank_field is always called 'rank'.
    ccnsql::append($dbh,$table,'rank',$where,$set);
}

sub cluster_usage($$)
{
    my ($type,$name) = @_;
    Pn "cluster_usage", {
        system_name => t"_{SYSNAME}_",
        type => $type,
        name => $name,
        provides => $type,
    };
}

sub cluster_provides($$$)
{
    my ($type,$name,$usage) = @_;
    Pn "cluster_usage", {
        system_name => t"_{SYSNAME}_",
        type => $type,
        name => $name,
        provides => $usage,
    };
}

sub uses_database($$$$)
{
    my ($type,$name,$dbcluster,$dbname) = @_;

    Pn "cluster_attributes", {
        system_name => t"_{SYSNAME}_",
        type => $type,
        name => $name,
        parameter => "database/cluster",
        value => $dbcluster,
    };
    Pn "cluster_attributes", {
        system_name => t"_{SYSNAME}_",
        type => $type,
        name => $name,
        parameter => "database/dbname",
        value => $dbname,
    };
}


sub server_member($$)
{
    my ($type,$name) = @_;
    Pn "server_cluster", {
        system_name => t"_{SYSNAME}_",
        server_name => t"_{SERVER}_",
        cluster_type => $type,
        cluster_name => $name,
    };
    Pn "cluster", {
        system_name => t"_{SYSNAME}_",
        type => $type,
        name => $name,
        label => $name,
    };
    cluser_usage($type,$name);
}


# These manipulate values in the larger database
our $sth_single = $dbh->prepare(q(INSERT OR REPLACE INTO single_valued(key,value) VALUES (?,?);))
    or die "Prepare: ".$dbh->errstr;
our $sth_string = $dbh->prepare(q(SELECT value FROM single_valued WHERE key = ?;))
    or die "Prepare: ".$dbh->errstr;
our $sth_multi  = $dbh->prepare(q(INSERT INTO multi_valued(key,value,rank) VALUES (?,?,?);))
    or die "Prepare: ".$dbh->errstr;
our $sth_already= $dbh->prepare(q(SELECT COUNT(*) FROM multi_valued WHERE key = ? AND value = ?;))
    or die "Prepare: ".$dbh->errstr;
our $sth_rank   = $dbh->prepare(q(SELECT COUNT(*) FROM multi_valued WHERE key = ?;))
    or die "Prepare: ".$dbh->errstr;

sub p($$) # "put"
{
    $sth_single->execute(t $_[0],$_[1])
        or die "Execute: ".$dbh->errstr;
    $sth_single->finish();
}

sub c($$) # "continue"
{
    my $key = t $_[0];
    $sth_string->execute($key);
    my @row_ary  = $sth_string->fetchrow_array;
    $sth_string->finish();

    my $current = $row_ary[0];

    $current = '' if not defined $current;
    $current .= $_[1];
    $sth_single->execute($key,$current)
        or die "Execute: ".$dbh->errstr;
    $sth_single->finish();
}

sub a($$) # "append" (array with unique values)
{
    my $t = t $_[0];
    $sth_already->execute($t,$_[1]);
    my @row_ary = $sth_already->fetchrow_array;
    $sth_already->finish();

    my $already = $row_ary[0];
    return if $already;

    $sth_rank->execute($t);
    @row_ary = $sth_rank->fetchrow_array;
    $sth_rank->finish();

    my $rank = $row_ary[0];
    $rank = 0 if not defined $rank;

    $sth_multi->execute($t,$_[1],$rank)
        or die "Execute: ".$dbh->errstr;
    $sth_multi->finish();
}

sub e($) # "get"
{
    my $t = t $_[0];
    $sth_string->execute($t)
        or die "Execute: ".$dbh->errstr;
    my @row_ary = $sth_string->fetchrow_array;
    $sth_string->finish();

    return $row_ary[0];
}


sub cidr($)
{
    my $bits = shift;
    return join('.',map {sprintf '%d', $_} unpack('C*',pack('N',0xffffffff-(0xffffffff>>$bits))));
}

our $qr_mac    = qr([a-f\d]{2}:?[a-f\d]{2}:?[a-f\d]{2}:?[a-f\d]{2}:?[a-f\d]{2}:?[a-f\d]{2})i;
sub qr_mac_clean($) { $a = lc(shift); $a =~ s/://g; return $a; }

our $qr_ip     = qr(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3});
sub qr_ip_clean($) { return shift; }

our $qr_digits = qr(\d+);
sub qr_digits_clean($) { return shift; }

our $qr_name   = qr([a-zA-Z]\w+);
sub qr_name_clean($) { return lc(shift); }

our $qr_dns    = qr([a-zA-Z][\w.-]+\.[\w.-]+);
sub qr_dns_clean($) { return lc(shift); }

our $qr_float  = qr(\d+(?:\.\d+)?);
sub qr_float_clean($) { return shift; }

our $qr_string = qr((?:"[^"]+"|\S.*\S));
sub qr_string_clean($) { return shift; }

our $qr_geo    = qr(\w+\.\w+);
sub qr_geo_clean($) { return shift; }

our $qr_tz     = qr((?:\w+/\w+|UTC));
sub qr_tz_clean($) { return shift; }

# map $digitmap ...
our $qr_digitmap = qr([*\dX]+);
sub qr_digitmap_clean($) { return uc(shift); }

# prepend ...
our $qr_number = qr([*#\d]+);
sub qr_number_clean($) { return shift; }

our $qr_context = qr([\w-]+);
sub qr_context_clean($) { return lc(shift); }

our $qr_sysname = qr($qr_dns);
sub qr_sysname_clean($) { return lc(shift); }

our $qr_cluster = qr($qr_name);
sub qr_cluster_clean($) { return lc(shift); }

our $qr_enterprise = qr($qr_digits);
sub qr_enterprise_clean($) { return sprintf('e%0'.t("_{EIDLEN}_").'d',shift); }

our $qr_pool   = qr($qr_digits);
sub qr_pool_clean($) { return sprintf('%0'.t("_{PIDLEN}_").'d',shift); }

our $qr_server = qr((?:$qr_dns|$qr_name));
sub qr_server_clean($) { $a = lc(shift); my $s = t"_{SYSNAME}_"; return ($a =~ /\.server\.$s$/) ? $a : $a.'.server.'.$s; }

our $qr_ipnet  = qr((?:$qr_ip $qr_ip|$qr_ip/$qr_digits));
sub qr_ipnet_clean($) { $a = shift; return ($a =~ /(\S+):(\S+)/) ? "$1:".cidr($2) : $a; }

# Note: for some reason (bug?) the order of the entries here is important.
our $qr_route  = qr((?:outbound-$qr_name|group-$qr_name|phones-$qr_name|$qr_name));
sub qr_route_clean($) { return lc(shift); }

our $qr_trunk  = qr($qr_digits);
sub qr_trunk_clean($) { return sprintf('%0'.t("_{TIDLEN}_").'d',shift); }

# System-generated qs
PERL0

# Pre-processor data
my %macros  = ();
my %macro_params = ();
my @contexts = ();
my @contexts_names = ();

# Simulate Perl's <>
my $fh;
my $filename;
if($#ARGV >= 0)
{
    $filename = shift @ARGV;
    open($fh,'<',$filename) or die "open $filename: $!";
}
else
{
    $filename = '/dev/stdin';
    $fh = \*STDIN;
}

# Parser data
our $context = '';
our $level   = 0;

MACROLOOP:
{
    while(<$fh>)
    {
        print STDERR ">> $_" if $check;

        chomp;
        s/^\s+//; s/\s+$//; s/\s+/ /g;
        next if /^$/;
        # XXX Keep comments
        next if m{^#|^//|^!};

        if( /^define macro (\w+)$/ )
        {
            my $name = $1;
            $macros{$name} = '';
            while(<$fh>)
            {
                last if /^\s*end\s+macro/;
                chomp;
                s/^\s+//; s/\s+$//; s/\s+/ /g;
                next if /^$/;
                $macros{$name} .= "$_\n";
            }
            # Find the number of arguments for the macro
            my $max = 0;
            my @values = ($macros{$name} =~ /\$(\d+)/g);
            foreach (@values) { $max = $_ if $_ > $max };
            $macro_params{$name} = $max;
            next;
        }
        if( /^macro (\w+)$/ )
        {
            push @contexts, $fh; push @contexts_names, $filename;
            my $text1 = $macros{$1};
            $fh = new FileHandle;
            open($fh,'<',\$text1) or die "macro $1 failed :$!";
            $filename = "macro $1";
            next;
        }
        if( /^macro (\w+) (\S.*)$/ )
        {
            push @contexts, $fh; push @contexts_names, $filename;
            my $text2 = $macros{$1};
            my @params = split(' ',$2,$macro_params{$1});

            $text2 =~ s/\$(\d+)/defined $params[$1-1] ? $params[$1-1] : "Invalid macro parameter \$$1"/ge;
            $fh = new FileHandle;
            open($fh,'<',\$text2) or die "macro $1 failed :$!";
            $filename = "macro $1";
            next;
        }
        if( /^macro/ )
        {
            die "Invalid macro syntax: $_";
        }
        if( /^include (\S.*)$/ )
        {
            push @contexts, $fh; push @contexts_names, $filename;
            my $file = $1;
            $file =~ s/^"(.*)"$/$1/;
            $fh = new FileHandle;
            open($fh,'<',$file) or die "include '$1' failed: $!";
            $filename = $file;
            next;
        }

        LOOP:
        {
            # Main parser branch
            my %syntax = (
PERL1
            ); # %syntax

            redo LOOP if /^(\S+)/ and exists $syntax{$1} and $syntax{$1}->();

        } # LOOP:

        next if /^\s*$/;
        die "Invalid syntax: '$_' (at $context, level $level)";
    }
    close($fh);

    $filename = pop(@contexts_names),
    (print STDERR "back to $filename\n"),
    redo MACROLOOP
        if defined( $fh = pop @contexts );

    if( $#ARGV >= 0 )
    {
        $filename = shift @ARGV;
        open($fh,'<',$filename) or die "open $filename: $!";
        redo MACROLOOP;
    }

}

if( not $check )
{
    undef $sth_single;
    undef $sth_string;
    undef $sth_multi;
    undef $sth_already;
    undef $sth_rank;
    # $dbh->commit;
    $dbh->disconnect;
}
PERL2
